;code for dynamic box-cox transformations (c) Pedro Valero 1999
;modified to conform with undocumented requirements
;by forrest young, sep 1999 and sep 2000.
;Corrected bugs with missing data March 2001 Pedro Valero

(provide "folded power")

(defun Folded-Power-transf
  (&key 
    (data      current-data)
   (dialog     nil)
   (name       "FP")
   (title      "Folded Power Transformations")
   )
  (send lambda-transf-object-proto :new 9 data title name dialog))

(defun folded-power-transf
  (&key 
    (data      current-data)
   (dialog     nil)
   (name       "FP")
   (title      "Folded Power Transformations")
   )
  (send lambda-transf-object-proto :new 9 data title name dialog))

(defun folded-power
  (&key 
   (data      current-data)
   (dialog     nil)
   (name       "FP")
   (title      "Folded Power Transformations")
   )
  (send lambda-transf-object-proto :new 9 data title name dialog))

(defun folded-power (x p)
  "Args:x variable to be transformed. P value for the transformations. Some interesting values of p are:
1  plurality
0.5 folded root square
0.41 Arcsin
0.14 Probit
0 Logit
<0 complementary log log function
Note: When data includes 0 or 1 p is settled to 0.01 to avoid computing log(0)"
	
    (cond 
      ((or (<  (min x) 0)
           (>  (max x) 1))
       x) ;if the data are not valid it just returns the original values

      ((and (< 0 (min x) )
            (> 1 (max x) )
            (= p 0))
       (/ (log (/ x (- 1 x))) 2))
      ((and (or (= (min x) 0)
                (= (max x) 1)
                )
            (<= p 0))
       (/ (- (^ (* 2 x) 0.01) 
             (^ (- 2 (* 2 x)) 0.01)) 
          (* 2 0.01)));if the data contains 1 or 0 p is equal to 0.01
     	 ((<= p 0)  (log (- (log (- 1 x))))) ;values of p equal to zero will return this when there are values of 0 or 1 in the original data	
      ((> p 1) x) ;values of p above 1 return the original variable
      (t (/ (- (^ (* 2 x) p) (^ (- 2 (* 2 x)) p)) (* 2 p)))))
 
   
(defproto lambda-transf-object-proto 
  '(bc-data transf-data values-list data-transf-out ) () transf-object-proto)

(defmeth lambda-transf-object-proto :transf-data 
  (&optional (values nil set))
  "Transformed data"
  (if set (setf (slot-value 'transf-data) values)      
  (slot-value 'transf-data)))

(defmeth lambda-transf-object-proto :data-transf-out  
  (&optional (objid nil set))
  "Object ID of Transformed data"
  (if set (setf (slot-value 'data-transf-out ) objid)      
  (slot-value 'data-transf-out )))

(defmeth lambda-transf-object-proto :bc-data 
  (&optional (values nil set))
  "data"
  (if set (setf (slot-value 'bc-data) values)      
  (slot-value 'bc-data)))

(defmeth lambda-transf-object-proto :values-list
  (&optional (values nil set))
  "Transformed data"
  (if set (setf (slot-value 'values-list) values)      
  (slot-value 'values-list)))

(defmeth lambda-transf-object-proto :isnew (&rest args)
  (apply #'call-next-method args))

(defmeth lambda-transf-object-proto :options () t)

;code in analysis was moved out of isnew by fwy 9/2000

(defmeth lambda-transf-object-proto :analysis ()
  (let* ((variables (send self :active-variables '(numeric)))
         (nvar (send self :active-nvar '(numeric)))
         (values-list (send self :values-list (repeat 1.01 nvar)))
         (bc-object self)
         (data-transf-out 
          (data (send self :name)          
                :created  (send *desktop* :selected-icon)          
                :title     (concatenate 'string "PW-"(send self :title))
                :variables (mapcar #'(lambda (var)
                                       (strcat var "-pw"))
                                   (send self :variables))
                :data (send self :active-data '(numeric))
                :labels (send self :active-labels)
                :types (send self :active-types '(numeric))
                ))
         )

;next line added by fwy 9/2000
    (send self :data-transf-out data-transf-out)

    (defmeth data-transf-out :transform-data (var p values-list)
      (let (
            (data-prev (column-list (send bc-object :data-matrix)))
            (data-t (column-list (send self :data-matrix)))
            (variable-selected var)
            (values-list values-list)
            (variables (send bc-object :variables))
            )
        (setf (select data-t variable-selected) 
               (function-with-missing #'folded-power 
                                       (select data-prev 
                                               variable-selected)
                                      (list (select values-list variable-selected))))
        (when (send self :datasheet-open)
              (send (send self :datasheet-object) :close))
        
;next statement removed by fwy 9/2000 so that
;variable names do not change from what they are
;at creation of data object, since varying the
;names will create havoc with the system
        (send self :variables 
              (map-elements 'concatenate 'string 
                            variables
                            "_p_" 
                            (mapcar #'(lambda (val) (format nil "~,2g" val))
                                    values-list)))
        (send self :data 
              (combine (transpose (map-elements 'coerce data-t 'list))))
        
        (setcd self)

        (send self :datasheet-object nil)))

    (send self :visualize-transformation)

    #+containers (send self :tmat-menu-item)

    ))

(defmeth lambda-transf-object-proto :visualize ()
;next line added by fwy 9/2000
  (setf *spreadplot-container* (make-container :size (send *vista* :spreadplot-sizes) 
                                          :free t :local-menus t :type 1 :show nil))
  (let* ((data-transf-out (send self :data-transf-out))
         (bc-object self)
         (column-data (column-list (send self :active-data-matrix '(numeric))))
         (lista-labels (name-list (send self :active-labels) 
                                  :title "Labels" :show nil));esto no se como funciona
         (vars (send self :variables))
         ;(a (break))
         (sct-matrix (cond
                       (
                        (all-rows-missing-p (apply 'bind-columns column-data))
                         (fatal-message "The listwise data matrix is empty"))
                        ((> (length column-data) 10)
                         (fatal-message "Power transformations currently works only with less than 11 (numeric) variables"))
                        ((> (length (send self :variables)) 1)
                         (scatterplot-matrix 
                          column-data :show nil)) ;the scatterplot matrix
                       ((equal (length (send self :variables)) 1)
                        (histogram column-data :show nil))
                       (t (qplot (first column-data) :show nil))
                       ))
         (sctp (if (= (length column-data) 1)
                   (histogram column-data)
                   (scatterplot column-data
                      :title "Scatterplot"
                      :show nil)))
         (qtl (quantile-plot (non-missing (select column-data 0)) :show nil)) ;the histogram
         (matrix-transf nil)
         (slider)
         )

    (send self :bc-data column-data)

;fwy added next lista-vars statements
    
    (send lista-labels :title "Observations")
    (send lista-labels :new-menu "Obs" 
          :items '(LINK MOUSE DASH ERASE-SELECTION FOCUS-ON-SELECTION 
                        SHOW-ALL COLOR SELECTION))
    (send lista-labels :fix-name-list)
    (send lista-labels :use-color t)
    (send lista-labels :point-color (iseq (send lista-labels :num-points)) 'blue)


    ;This is a list of ones for initial values of the slider
    (send self :values-list (repeat 1.01 (length column-data)))
   
    ;;;;;scatterplot
   (when (> (length column-data) 1) (send sctp :make-scatterplot-curves)
         (send sctp :vista-look-and-feel)
    (send sctp :point-label 
          (iseq (send sctp :num-points))
          (send self :active-labels)))
    (send sctp
             :variable-label (iseq 0 (- (length column-data) 1))
             (send self :variables))
    (defmeth sctp :plot-help ()
      (plot-help-window (strcat "Help for " (send self :title)))
      (paste-plot-help 
       (format nil "This scatterplot is a bigger version of the plots in the scatterplot matrix. Clicking in the corresponding plot results in this scatterplot changing. Clicking on the diagonal results in a plot of the untransformed variable v. the transformed variable."))
      (show-plot-help))
    ;;;;plot quantile
    (send qtl :plot-buttons :new-y nil)
    (send qtl :showing-labels nil)
    (defmeth qtl :plot-help ()
      (plot-help-window (strcat "Help for " (send self :title)))
      (paste-plot-help (format nil "This quantile plots shows the shape of the transformed variable. You usually look for a straight line along the diagonal.~2%"))
      (show-plot-help))
    ;;;;;scatterplot matrix
    (send sct-matrix 
          :variable-label (iseq 0 (- (length column-data) 1))
          (send self :variables))
    (send sct-matrix :point-label 
          (iseq (send sct-matrix :num-points))
          (send self :active-labels))
    (send sct-matrix 
          :plot-buttons 
             :margin (list 0 17 0 0) 
             :new-x nil 
             :new-y nil 
             :mouse-mode t)
       (send sct-matrix :use-color t)

    (defmeth sct-matrix :plot-help ()
      (box-cox-help))
    (defun box-cox-help ()
      (plot-help-window (strcat "Help for " (send self :title)))
      (paste-plot-help (format nil "The family of transformations here applied are basically linear in the centre of the distribution but folds data in the ties. Some (statistically) interesting values of the slider are:
1 : plurality
0.5 folded root square
0.41 Arcsin
0.14 Probit
0 Logit~2%"))
      (show-plot-help))
    
;fwy 090699
;speadplot modified to omit variable list (variable selection 
;added to scatmat) and to use new cell-spanning feature
;

    (setf matrix-transf
          (spread-plot
           (matrix (list 2 3)
                   (list sct-matrix qtl lista-labels 
                         nil        sctp       nil ))
           :container *spreadplot-container*
           :supplemental-plot slider
           :rel-widths (list 2 1 .5)
           
           :span-down (matrix (list 2 3) (list 2 1 2 0 1 0))))

;(send matrix-transf :show-spreadplot)
    

    (defmeth matrix-transf :spreadplot-help ()
      (plot-help-window (strcat "Spreadplot Help"))
      (paste-plot-help (format nil "The Power folded transformations can improve the shape of the relationships between variables which are proportion and others which are continuous by making them more linear. This happens because variables which are proportions are limited on the extremes. The power folded transformations stretches the ties of the variables, allowing that relationships on the extremes arise more linear.
The family of transformations here applied are basically linear in the centre of the distribution but folds data in the ties. Some (statistically) interesting values of the slider are:
1 : plurality
0.5 folded root square
0.41 Arcsin
0.14 Probit
0 Logit "))
      (show-plot-help))
    (setf slider
          (interval-slider-dialog (list -.01 1.01)
           :points 100
           :show nil         
           :nice t
           :action #'(lambda (p)
                       (setf val-list (send self :values-list))
                       (setf (select val-list 
                                     (first (send sct-matrix :current-variables)))
                             (send slider :value))
                       (send self :values-list val-list)
                       (send data-transf-out :transform-data 
                             (first (send sct-matrix :current-variables))
                             (send slider :value)
                             (send self :values-list))                            
                             (send matrix-transf :update-spreadplot "slider" "slider" ))))

;;;;defines the communication between plots using spreadplot arquitecture

    (defmeth qtl :do-click (a b c d)
      (call-next-method a b c d)
      (send matrix-transf :update-spreadplot 
            "qtl" "qtl" 
            (send self :selection)
            (send self :point-color (iseq 0 (1- (send self :num-points)))))
      )


   (defmeth sct-matrix :do-click (a b c d)
       (call-next-method a b c d)
       (send matrix-transf :update-spreadplot 
             "sct-matrix" 
             "sct-matrix"
             (send self :mouse-mode)
       ))

    (defmeth lista-labels :do-click (a b c d)
      (call-next-method a b c d)
      (send matrix-transf :update-spreadplot "labels" "labels" 
            (send self :selection) 
            (send self :point-color (iseq 0 (1- (send self :num-points)))))
      )
    
    (defmeth qtl :update-plotcell (i j &rest args)
      (let* (
             (row i)
             (column j)
             (variable nil)
             (selection nil)
             (args args)
             (color nil)
             (data (column-list (send (send bc-object :data-transf-out) :data-matrix)))
             (variable-selected (list (first (send sct-matrix :current-variables))))
             (variable-name (apply 'select (send bc-object :variables) variable-selected))
             (mouse-mode (princ-to-string (third (combine args))))
            )
        (cond 
          ((or (equal row "slider") 
               (and (equal row "sct-matrix") 
                    (equal mouse-mode "FOCUS-ON-VARIABLES")))
           (send self :start-buffering)
           (send self :new-plot (non-missing (apply 'select data variable-selected)))
            (send self :range 0 
                   (min (send self :point-coordinate 0
                              (iseq (send self :num-points))))
                   (max (send self :point-coordinate 0
                              (iseq (send self :num-points)))))
             (send self :range 1 
                   (min (send self :point-coordinate 1
                              (iseq (send self :num-points))))
                   (max (send self :point-coordinate 1
                              (iseq (send self :num-points)))))
           (send self :buffer-to-screen)
           (send self :title (strcat (send self :title) " of " variable-name))
           ))))
               
  (defmeth sctp :update-plotcell (i j &rest args)
        (let (
              (vars (send sct-matrix :current-variables))
              (data (column-list (send (send bc-object :data-transf-out) :data-matrix)))
              (raw-data (send bc-object :bc-data))
              (labels (send self :point-label (iseq (send self :num-points))))
              (row i)
              (mouse-mode (princ-to-string (third (combine args))))
              (name-vars (send bc-object :variables))
              )
          (when (= (length data) 1)
                (send self :start-buffering)
                (send self :clear-points)
                (send self :add-points (non-missing (first data)))
                (send self :adjust-to-data)
                (send self :buffer-to-screen))
          (when (> (length data) 1)
          (cond 
            ((or (equal row "slider")
                 (and (equal row "sct-matrix")
                      (equal mouse-mode "FOCUS-ON-VARIABLES")))
             (send self :start-buffering)
             (send self :clear-lines)
             (cond
               ((equal (first vars) (second vars))
                (let* (
                      (n (send self :num-points))
                      (non-nil-first (which (select raw-data (first vars))))
                      (nil-first (set-difference (iseq n) non-nil-first))
                      (non-nil-second (which (select data (second vars))))
                      (nil-second (set-difference (iseq n) non-nil-second))
                      (both-non-nil (remove-duplicates (combine non-nil-first non-nil-second)))
                      (both-nil (remove 'nil (remove-duplicates (combine nil-first nil-second))))
                       (first-var-data (select (select raw-data (first vars)) non-nil-first))
                       (second-var-data (select (select data (second vars)) non-nil-second))
                      )
                  (send self :point-coordinate 0
                      non-nil-first
                      first-var-data)
                 (when nil-first (send self :point-coordinate 0
                        nil-first
                        (mean first-var-data)))
                  (send self :point-coordinate 1
                        non-nil-second
                        second-var-data)
                 (when nil-second (send self :point-coordinate 1
                        nil-second
                        (mean second-var-data)))
                  (send self :point-state both-non-nil 'normal)
                  (when both-nil (send self :point-state both-nil 'invisible))
                  
                  (send self :variable-label 0 (select name-vars (first vars)))
                  (send self :variable-label 1 
                        (strcat (select name-vars (second vars))
                                " Transformed"))
                  (setf vars (list 0 1))))
                
               (t 
                (let* (
                      (n (send self :num-points))
                      (non-nil-first (which (select data (first vars))))
                      (nil-first (set-difference (iseq n) non-nil-first))
                      (non-nil-second (which (select data (second vars))))
                      (nil-second (set-difference (iseq n) non-nil-second))
                      (both-non-nil (remove-duplicates (combine non-nil-first non-nil-second)))
                      (both-nil (remove 'nil (remove-duplicates (combine nil-first nil-second))))
                       (first-var-data (select (select data (first vars)) non-nil-first))
                       (second-var-data (select (select data (second vars)) non-nil-second))
                       
                      )
                  (send self :point-coordinate (first vars)
                      non-nil-first
                      first-var-data)
                 (when nil-first (send self :point-coordinate (first vars)
                        nil-first
                        (mean first-var-data)));mean is used for missing values
                                               ;this affects the computation of curves
                                               ;but no other solution until yet
                  (send self :point-coordinate (second vars) 
                        non-nil-second
                        second-var-data)
                  (when nil-second (send self :point-coordinate (second vars) 
                        nil-second
                        (mean second-var-data)))
                  (send self :variable-label (first vars)
                        (select name-vars (first vars)))
                  (send self :variable-label (second vars)
                              (select name-vars (second vars)))
                  (send self :point-state both-non-nil 'normal)
                  (when both-nil (send self :point-state both-nil 'invisible))
                  )))
             (send self :current-variables (first vars) (second vars))
             (send self :adjust-to-data) 
             (let ((NORMAL (WHICH (MAPCAR 
                                  (FUNCTION (LAMBDA (VAL) 
                                              (EQUAL 'NORMAL VAL))) 
                                  (SEND SELF :POINT-STATE (iseq (SEND SELF :NUM-POINTS))))))
                   )

               
               (mapcar #'(lambda (var)
                           (let* ((min (min (send self :point-coordinate var normal)))
                                  (max  (max (send self :point-coordinate var normal)))
                                  (dist (* 0.05 (- max min)))
                                  )
                             (send self :range var
                                   (- min dist)
                                   (+ max dist))))
                       (list (first vars) (second vars)))
               
               (send self :redraw-curves)
               (send self :buffer-to-screen)             
               (send self :point-label (iseq (send self :num-points)) labels))  
             )))))

  (defmeth sct-matrix :update-plotcell (i j &rest args)
        (let* 
          (
           (row i)
           (column j)
           (args args)
           (data-transf nil) 
           (selection nil) 
           (color nil)
           (labels  (send self :point-label 
                          (iseq (send self :num-points))))
           )
          (cond 
            ((equal row "slider")
             (setf data-transf (column-list (send 
                                             (send bc-object :data-transf-out)
                                             :data-matrix)))
             (setf selection (send self :selection))
             (setf color (send self :point-color (iseq (send self :num-points))))

             (send self :point-color (iseq (send self :num-points)) color)
             (send self :selection selection)
             (send self :start-buffering)      
             (send self :clear)    
             (send self :add-points data-transf :draw nil ) 
             (send self :point-color (iseq (send self :num-points)) color)
             (send self :selection selection)
             (send self :adjust-to-data)
             (send self :redraw)
             (send self :buffer-to-screen)   
                 ))
          (send self :point-label (iseq (send self :num-points)) labels)
          ))

    (defmeth lista-labels :update-plotcell (i j &rest args)
      (let ((row i)
           (column j)
           (args args))
        (send self :use-color t)
        (send self :redraw)))

    (defmeth slider :update-plotcell (i j &rest args)
      (let (
            (args (combine args))
            (sender i)
            (mouse-mode (princ-to-string (third (combine args))))
            (current-variable 
             (first (send sct-matrix :current-variables)))
            (vals (send bc-object :values-list))
            )
        (when (and (equal sender "sct-matrix") 
                   (equal mouse-mode "FOCUS-ON-VARIABLES"))
              (send self :value (select vals current-variable)))))


;fwy 090699
;following sct-matrix statements added by forrest young
;they add variable-focus method and color

    (send sct-matrix :linked t)
    (send sct-matrix :use-color t)
    (send sct-matrix :point-color (iseq (send sct-matrix :num-points)) 'blue)
    (send sct-matrix :add-mouse-mode 'focus-on-variables
          :title "Focus On Variables"
          :click :do-new-variable-focus
          :cursor 'finger)
    (send sct-matrix :plot-buttons :new-x nil :new-y nil)
    (send sct-matrix :mouse-mode 'focus-on-variables)
   (defmeth sct-matrix :do-new-variable-focus (x y m1 m2)    
      (send matrix-transf :update-spreadplot "sct-matrix" "sct-matrix"
            (send self :current-variables)
            (send self :mouse-mode)))

    (defmeth matrix-transf :update-spreadplot (i j &rest args)
      (mapcar #'(lambda (plot)
                  (send plot :update-plotcell i j args))
              (combine (send self :all-plots) slider)))

 (defmeth slider :update-from-spreadplot 
        (i j &rest args)
        (let
          (
           
           (variable-selected (first args))
           (data (second args))
           (data-transf (third args))         
           (values-list (fourth args))
           )
          (send matrix-transf :transf-data data-transf)
          (setf (select values-list variable-selected) 
                (/ (round (* 10 (send self :value)))
                   10)) ;sets the value in the slider          
          (send matrix-transf :update-spreadplot 
                1 0  variable-selected data values-list) 
                 ))
    (send sct-matrix :linked t)
    (send lista-labels :linked t)
    (send sctp :linked t)
    (send qtl :linked t)
    (defmeth slider :install-plot-help-item ()) ;it is empty, has to be filled.
    (defmeth slider :remove-plot-help-item ())
    (defmeth slider :redraw ())

    (defmeth slider :plot-help ()
      (plot-help-window (strcat "Help for " (send self :title)))
      (paste-plot-help (format nil "This plot shows the power of the transformation applied to the variable selected~2%"))
      (show-plot-help))

    ;fwy 090999 - added next statement
    ;======================================================
#+containers
   (send matrix-transf :make-spreadplot-container-resize *spreadplot-container*)
   (send slider :value 1.01)
    
;======================================================
;fwy 092599 - added remaining code - requires containers
;======================================================

#+containers
(defmeth lambda-transf-object-proto :tmat-menu-item ()
  (let ((lastitem (first (last (send *spreadplot-window-menu* :items))))
        )
    (send *spreadplot-window-menu* :delete-items lastitem)
    (send *spreadplot-window-menu* :delete-items
          (first (last (send *spreadplot-window-menu* :items))))
    (send *spreadplot-window-menu* :append-items

          (send menu-item-proto :new "Transformation PlotMatrix"
                :action #'(lambda ()(send self :t-scatmat)))
          (send dash-item-proto :new)
          lastitem)))

#+containers
(defmeth lambda-transf-object-proto :t-scatmat ()
  (setf *spreadplot-container* (make-container :size (send *vista* :spreadplot-sizes) 
                                          :free t :local-menus t :type 1 :show nil))
  (let* ((raw-vars (send self :bc-data))
         (trans-vars (column-list (send (send self :data-transf-out) :data-matrix)))
         (nvar (length raw-vars))
         (obs-labs (name-list (send self :active-labels) 
                                  :title "Observations" :show nil))
         (plot-vec (matrix (list nvar 1) (combine obs-labs (repeat nil (1- nvar)))))
         (plots)
         (plot-matrix)
         (sp))
    (mapcar #'(lambda (raw-vary trans-vary i)
                (mapcar #'(lambda (raw-varx trans-varx j)
                            (cond 
                              ((< i j)
                               (setf pp (plot-points (list (eval raw-vary) 
                                                           (eval raw-varx)) 
                                                     :show t)))
                              ((= i j)
                               (setf pp (plot-points (list (eval raw-vary) 
                                                           (eval trans-vary)) 
                                                     :show t)))
                              ((> i j)
                               (setf pp (plot-points (list (eval trans-varx) 
                                                           (eval trans-vary))
                                                     :show t))))
                            (send pp :showing-labels nil)
                            (send pp :use-color t)
                            (send pp :point-color (iseq (send pp :num-points)) 'blue)
                            (send pp :mouse-mode 'brushing)
                            (send pp :x-axis nil)
                            (send pp :y-axis nil)
                            (send pp :legend1 " ")
                            (send pp :legend2 " ")
                            (send pp :make-scatterplot-curves) 
                            (send pp :lowess-fraction .5)
                            (send pp :switch-add-linear)
                            (send pp :switch-add-lowess)
                            (setf plots (append plots (list pp))))
                        raw-vars trans-vars (iseq nvar)))
            (reverse raw-vars) (reverse trans-vars) (reverse (iseq nvar)))
    (setf plot-matrix (matrix (list nvar nvar) (combine plots)))
    (setf plots (combine (bind-columns plot-vec plot-matrix)))
    (setf sp (spread-plot (matrix (list nvar (1+ nvar)) plots)
                          :rel-widths (combine (ceiling (/ nvar 3)) (repeat 1 nvar))
                          :span-down (matrix (list nvar (1+ nvar) )
                                    (combine nvar (repeat 1 nvar)
                                             (repeat (combine 0 (repeat 1 nvar)) 
                                                     (1- nvar))))))
    (mapcar #'(lambda (plot) (when plot (send plot :linked t))) plots)
    (send sp :show-spreadplot)
    (apply #'send *spreadplot-container* :size (send *vista* :spreadplot-sizes))
    (send *spreadplot-container* :show-window) 
    c))
))

